home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / xlispsrc.arc / XLLIST.C < prev    next >
C/C++ Source or Header  |  1988-02-11  |  20KB  |  916 lines
  1. /* xllist.c - xlisp built-in list functions */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. /* forward declarations */
  9. FORWARD LVAL cxr();
  10. FORWARD LVAL nth(),assoc();
  11. FORWARD LVAL subst(),sublis(),map();
  12.  
  13. /* xcar - take the car of a cons cell */
  14. LVAL xcar()
  15. {
  16.     LVAL list;
  17.     list = xlgalist();
  18.     xllastarg();
  19.     return (list ? car(list) : NIL);
  20. }
  21.  
  22. /* xcdr - take the cdr of a cons cell */
  23. LVAL xcdr()
  24. {
  25.     LVAL list;
  26.     list = xlgalist();
  27.     xllastarg();
  28.     return (list ? cdr(list) : NIL);
  29. }
  30.  
  31. /* cxxr functions */
  32. LVAL xcaar() { return (cxr("aa")); }
  33. LVAL xcadr() { return (cxr("da")); }
  34. LVAL xcdar() { return (cxr("ad")); }
  35. LVAL xcddr() { return (cxr("dd")); }
  36.  
  37. /* cxxxr functions */
  38. LVAL xcaaar() { return (cxr("aaa")); }
  39. LVAL xcaadr() { return (cxr("daa")); }
  40. LVAL xcadar() { return (cxr("ada")); }
  41. LVAL xcaddr() { return (cxr("dda")); }
  42. LVAL xcdaar() { return (cxr("aad")); }
  43. LVAL xcdadr() { return (cxr("dad")); }
  44. LVAL xcddar() { return (cxr("add")); }
  45. LVAL xcdddr() { return (cxr("ddd")); }
  46.  
  47. /* cxxxxr functions */
  48. LVAL xcaaaar() { return (cxr("aaaa")); }
  49. LVAL xcaaadr() { return (cxr("daaa")); }
  50. LVAL xcaadar() { return (cxr("adaa")); }
  51. LVAL xcaaddr() { return (cxr("ddaa")); }
  52. LVAL xcadaar() { return (cxr("aada")); }
  53. LVAL xcadadr() { return (cxr("dada")); }
  54. LVAL xcaddar() { return (cxr("adda")); }
  55. LVAL xcadddr() { return (cxr("ddda")); }
  56. LVAL xcdaaar() { return (cxr("aaad")); }
  57. LVAL xcdaadr() { return (cxr("daad")); }
  58. LVAL xcdadar() { return (cxr("adad")); }
  59. LVAL xcdaddr() { return (cxr("ddad")); }
  60. LVAL xcddaar() { return (cxr("aadd")); }
  61. LVAL xcddadr() { return (cxr("dadd")); }
  62. LVAL xcdddar() { return (cxr("addd")); }
  63. LVAL xcddddr() { return (cxr("dddd")); }
  64.  
  65. /* cxr - common car/cdr routine */
  66. LOCAL LVAL cxr(adstr)
  67.   char *adstr;
  68. {
  69.     LVAL list;
  70.  
  71.     /* get the list */
  72.     list = xlgalist();
  73.     xllastarg();
  74.  
  75.     /* perform the car/cdr operations */
  76.     while (*adstr && consp(list))
  77.     list = (*adstr++ == 'a' ? car(list) : cdr(list));
  78.  
  79.     /* make sure the operation succeeded */
  80.     if (*adstr && list)
  81.     xlfail("bad argument");
  82.  
  83.     /* return the result */
  84.     return (list);
  85. }
  86.  
  87. /* xcons - construct a new list cell */
  88. LVAL xcons()
  89. {
  90.     LVAL arg1,arg2;
  91.  
  92.     /* get the two arguments */
  93.     arg1 = xlgetarg();
  94.     arg2 = xlgetarg();
  95.     xllastarg();
  96.  
  97.     /* construct a new list element */
  98.     return (cons(arg1,arg2));
  99. }
  100.  
  101. /* xlist - built a list of the arguments */
  102. LVAL xlist()
  103. {
  104.     LVAL last,next,val;
  105.  
  106.     /* protect some pointers */
  107.     xlsave1(val);
  108.  
  109.     /* add each argument to the list */
  110.     for (val = NIL; moreargs(); ) {
  111.  
  112.     /* append this argument to the end of the list */
  113.     next = consa(nextarg());
  114.     if (val) rplacd(last,next);
  115.     else val = next;
  116.     last = next;
  117.     }
  118.  
  119.     /* restore the stack */
  120.     xlpop();
  121.  
  122.     /* return the list */
  123.     return (val);
  124. }
  125.  
  126. /* xappend - built-in function append */
  127. LVAL xappend()
  128. {
  129.     LVAL list,last,next,val;
  130.  
  131.     /* protect some pointers */
  132.     xlsave1(val);
  133.  
  134.     /* initialize */
  135.     val = NIL;
  136.     
  137.     /* append each argument */
  138.     if (moreargs()) {
  139.     while (xlargc > 1) {
  140.  
  141.         /* append each element of this list to the result list */
  142.         for (list = nextarg(); consp(list); list = cdr(list)) {
  143.         next = consa(car(list));
  144.         if (val) rplacd(last,next);
  145.         else val = next;
  146.         last = next;
  147.         }
  148.     }
  149.  
  150.     /* handle the last argument */
  151.     if (val) rplacd(last,nextarg());
  152.     else val = nextarg();
  153.     }
  154.  
  155.     /* restore the stack */
  156.     xlpop();
  157.  
  158.     /* return the list */
  159.     return (val);
  160. }
  161.  
  162. /* xreverse - built-in function reverse */
  163. LVAL xreverse()
  164. {
  165.     LVAL list,val;
  166.  
  167.     /* protect some pointers */
  168.     xlsave1(val);
  169.  
  170.     /* get the list to reverse */
  171.     list = xlgalist();
  172.     xllastarg();
  173.  
  174.     /* append each element to the head of the result list */
  175.     for (val = NIL; consp(list); list = cdr(list))
  176.     val = cons(car(list),val);
  177.  
  178.     /* restore the stack */
  179.     xlpop();
  180.  
  181.     /* return the list */
  182.     return (val);
  183. }
  184.  
  185. /* xlast - return the last cons of a list */
  186. LVAL xlast()
  187. {
  188.     LVAL list;
  189.  
  190.     /* get the list */
  191.     list = xlgalist();
  192.     xllastarg();
  193.  
  194.     /* find the last cons */
  195.     while (consp(list) && cdr(list))
  196.     list = cdr(list);
  197.  
  198.     /* return the last element */
  199.     return (list);
  200. }
  201.  
  202. /* xmember - built-in function 'member' */
  203. LVAL xmember()
  204. {
  205.     LVAL x,list,fcn,val;
  206.     int tresult;
  207.  
  208.     /* protect some pointers */
  209.     xlsave1(fcn);
  210.  
  211.     /* get the expression to look for and the list */
  212.     x = xlgetarg();
  213.     list = xlgalist();
  214.     xltest(&fcn,&tresult);
  215.  
  216.     /* look for the expression */
  217.     for (val = NIL; consp(list); list = cdr(list))
  218.     if (dotest2(x,car(list),fcn) == tresult) {
  219.         val = list;
  220.         break;
  221.     }
  222.  
  223.     /* restore the stack */
  224.     xlpop();
  225.  
  226.     /* return the result */
  227.     return (val);
  228. }
  229.  
  230. /* xassoc - built-in function 'assoc' */
  231. LVAL xassoc()
  232. {
  233.     LVAL x,alist,fcn,pair,val;
  234.     int tresult;
  235.  
  236.     /* protect some pointers */
  237.     xlsave1(fcn);
  238.  
  239.     /* get the expression to look for and the association list */
  240.     x = xlgetarg();
  241.     alist = xlgalist();
  242.     xltest(&fcn,&tresult);
  243.  
  244.     /* look for the expression */
  245.     for (val = NIL; consp(alist); alist = cdr(alist))
  246.     if ((pair = car(alist)) && consp(pair))
  247.         if (dotest2(x,car(pair),fcn) == tresult) {
  248.         val = pair;
  249.         break;
  250.         }
  251.  
  252.     /* restore the stack */
  253.     xlpop();
  254.  
  255.     /* return result */
  256.     return (val);
  257. }
  258.  
  259. /* xsubst - substitute one expression for another */
  260. LVAL xsubst()
  261. {
  262.     LVAL to,from,expr,fcn,val;
  263.     int tresult;
  264.  
  265.     /* protect some pointers */
  266.     xlsave1(fcn);
  267.  
  268.     /* get the to value, the from value and the expression */
  269.     to = xlgetarg();
  270.     from = xlgetarg();
  271.     expr = xlgetarg();
  272.     xltest(&fcn,&tresult);
  273.  
  274.     /* do the substitution */
  275.     val = subst(to,from,expr,fcn,tresult);
  276.  
  277.     /* restore the stack */
  278.     xlpop();
  279.  
  280.     /* return the result */
  281.     return (val);
  282. }
  283.  
  284. /* subst - substitute one expression for another */
  285. LOCAL LVAL subst(to,from,expr,fcn,tresult)
  286.   LVAL to,from,expr,fcn; int tresult;
  287. {
  288.     LVAL carval,cdrval;
  289.  
  290.     if (dotest2(expr,from,fcn) == tresult)
  291.     return (to);
  292.     else if (consp(expr)) {
  293.     xlsave1(carval);
  294.     carval = subst(to,from,car(expr),fcn,tresult);
  295.     cdrval = subst(to,from,cdr(expr),fcn,tresult);
  296.     xlpop();
  297.     return (cons(carval,cdrval));
  298.     }
  299.     else
  300.     return (expr);
  301. }
  302.  
  303. /* xsublis - substitute using an association list */
  304. LVAL xsublis()
  305. {
  306.     LVAL alist,expr,fcn,val;
  307.     int tresult;
  308.  
  309.     /* protect some pointers */
  310.     xlsave1(fcn);
  311.  
  312.     /* get the assocation list and the expression */
  313.     alist = xlgalist();
  314.     expr = xlgetarg();
  315.     xltest(&fcn,&tresult);
  316.  
  317.     /* do the substitution */
  318.     val = sublis(alist,expr,fcn,tresult);
  319.  
  320.     /* restore the stack */
  321.     xlpop();
  322.  
  323.     /* return the result */
  324.     return (val);
  325. }
  326.  
  327. /* sublis - substitute using an association list */
  328. LOCAL LVAL sublis(alist,expr,fcn,tresult)
  329.   LVAL alist,expr,fcn; int tresult;
  330. {
  331.     LVAL carval,cdrval,pair;
  332.  
  333.     if (pair = assoc(expr,alist,fcn,tresult))
  334.     return (cdr(pair));
  335.     else if (consp(expr)) {
  336.     xlsave1(carval);
  337.     carval = sublis(alist,car(expr),fcn,tresult);
  338.     cdrval = sublis(alist,cdr(expr),fcn,tresult);
  339.     xlpop();
  340.     return (cons(carval,cdrval));
  341.     }
  342.     else
  343.     return (expr);
  344. }
  345.  
  346. /* assoc - find a pair in an association list */
  347. LOCAL LVAL assoc(expr,alist,fcn,tresult)
  348.   LVAL expr,alist,fcn; int tresult;
  349. {
  350.     LVAL pair;
  351.  
  352.     for (; consp(alist); alist = cdr(alist))
  353.     if ((pair = car(alist)) && consp(pair))
  354.         if (dotest2(expr,car(pair),fcn) == tresult)
  355.         return (pair);
  356.     return (NIL);
  357. }
  358.  
  359. /* xremove - built-in function 'remove' */
  360. LVAL xremove()
  361. {
  362.     LVAL x,list,fcn,val,last,next;
  363.     int tresult;
  364.  
  365.     /* protect some pointers */
  366.     xlstkcheck(2);
  367.     xlsave(fcn);
  368.     xlsave(val);
  369.  
  370.     /* get the expression to remove and the list */
  371.     x =